home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / win / vbsmpls.zip / SAMPLES / VISIBASE / MAIN.FRM < prev    next >
Text File  |  1994-03-24  |  20KB  |  593 lines

  1. VERSION 2.00
  2. Begin Form main 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "VISIBASE"
  5.    ClientHeight    =   4845
  6.    ClientLeft      =   1530
  7.    ClientTop       =   1530
  8.    ClientWidth     =   6855
  9.    Height          =   5250
  10.    Icon            =   MAIN.FRX:0000
  11.    Left            =   1470
  12.    LinkTopic       =   "Form1"
  13.    ScaleHeight     =   4845
  14.    ScaleWidth      =   6855
  15.    Top             =   1185
  16.    Width           =   6975
  17.    Begin OLE oleWordDocument 
  18.       Class           =   "Word.Document.6"
  19.       DisplayType     =   1  'Icon
  20.       fFFHk           =   -1  'True
  21.       Height          =   1215
  22.       Left            =   2640
  23.       MiscFlags       =   2
  24.       OLETypeAllowed  =   0  'Linked
  25.       SizeMode        =   2  'AutoSize
  26.       TabIndex        =   9
  27.       Top             =   600
  28.       Width           =   1215
  29.    End
  30.    Begin SSPanel helpbar 
  31.       Alignment       =   1  'Left Justify - MIDDLE
  32.       BackColor       =   &H00C0C0C0&
  33.       BevelInner      =   1  'Inset
  34.       BevelOuter      =   0  'None
  35.       Font3D          =   0  'None
  36.       FontBold        =   0   'False
  37.       FontItalic      =   0   'False
  38.       FontName        =   "MS Sans Serif"
  39.       FontSize        =   8.25
  40.       FontStrikethru  =   0   'False
  41.       FontUnderline   =   0   'False
  42.       Height          =   315
  43.       Left            =   0
  44.       TabIndex        =   14
  45.       Top             =   4440
  46.       Width           =   6765
  47.    End
  48.    Begin SSPanel Panel3D2 
  49.       BackColor       =   &H00C0C0C0&
  50.       BevelInner      =   1  'Inset
  51.       BevelOuter      =   0  'None
  52.       Font3D          =   0  'None
  53.       Height          =   2415
  54.       Left            =   4080
  55.       TabIndex        =   13
  56.       Top             =   0
  57.       Width           =   2535
  58.       Begin SSPanel Panel3D3 
  59.          BackColor       =   &H00C0C0C0&
  60.          Font3D          =   0  'None
  61.          Height          =   2175
  62.          Left            =   120
  63.          TabIndex        =   15
  64.          Top             =   120
  65.          Width           =   2295
  66.          Begin Image imgPhoto 
  67.             DataField       =   "Photo"
  68.             DataSource      =   "datEmployeeDatabase"
  69.             Height          =   1935
  70.             Left            =   120
  71.             Stretch         =   -1  'True
  72.             Top             =   120
  73.             Width           =   2055
  74.          End
  75.       End
  76.    End
  77.    Begin SSCommand cmdExit 
  78.       Caption         =   "E&xit"
  79.       Font3D          =   0  'None
  80.       Height          =   375
  81.       Left            =   4680
  82.       TabIndex        =   12
  83.       Top             =   3960
  84.       Width           =   1245
  85.    End
  86.    Begin Data datEmployeeDatabase 
  87.       BackColor       =   &H00C0C0C0&
  88.       Caption         =   "Employees"
  89.       Connect         =   ""
  90.       DatabaseName    =   "C:\MICROSOF\NEWSLETT.MDB"
  91.       Exclusive       =   0   'False
  92.       Height          =   315
  93.       Left            =   3960
  94.       Options         =   0
  95.       ReadOnly        =   0   'False
  96.       RecordSource    =   "personnel"
  97.       Top             =   2640
  98.       Width           =   2670
  99.    End
  100.    Begin SSCommand DeleteRecord 
  101.       Caption         =   "&Delete"
  102.       Font3D          =   0  'None
  103.       Height          =   330
  104.       Left            =   5400
  105.       TabIndex        =   11
  106.       Top             =   3120
  107.       Width           =   1275
  108.    End
  109.    Begin SSCommand AddRecord 
  110.       Caption         =   "&Add"
  111.       Font3D          =   0  'None
  112.       Height          =   330
  113.       Left            =   3960
  114.       TabIndex        =   10
  115.       Top             =   3120
  116.       Width           =   1320
  117.    End
  118.    Begin TextBox txtBiography 
  119.       DataSource      =   "datEmployeeDatabase"
  120.       FontBold        =   0   'False
  121.       FontItalic      =   0   'False
  122.       FontName        =   "MS Sans Serif"
  123.       FontSize        =   8.25
  124.       FontStrikethru  =   0   'False
  125.       FontUnderline   =   0   'False
  126.       Height          =   2055
  127.       Left            =   120
  128.       MultiLine       =   -1  'True
  129.       ScrollBars      =   2  'Vertical
  130.       TabIndex        =   4
  131.       Text            =   "txtBiography"
  132.       Top             =   2310
  133.       Width           =   3750
  134.    End
  135.    Begin SSCommand Change 
  136.       Caption         =   "&Change Newsletter"
  137.       Font3D          =   0  'None
  138.       Height          =   375
  139.       Left            =   3960
  140.       TabIndex        =   8
  141.       Top             =   3480
  142.       Width           =   2715
  143.    End
  144.    Begin TextBox txtStartDate 
  145.       DataSource      =   "datEmployeeDatabase"
  146.       FontBold        =   0   'False
  147.       FontItalic      =   0   'False
  148.       FontName        =   "MS Sans Serif"
  149.       FontSize        =   8.25
  150.       FontStrikethru  =   0   'False
  151.       FontUnderline   =   0   'False
  152.       Height          =   290
  153.       Left            =   60
  154.       TabIndex        =   3
  155.       Text            =   "txtStartDate"
  156.       Top             =   1575
  157.       Width           =   2402
  158.    End
  159.    Begin TextBox txtLastName 
  160.       DataField       =   "Lastname"
  161.       DataSource      =   "datEmployeeDatabase"
  162.       FontBold        =   0   'False
  163.       FontItalic      =   0   'False
  164.       FontName        =   "MS Sans Serif"
  165.       FontSize        =   8.25
  166.       FontStrikethru  =   0   'False
  167.       FontUnderline   =   0   'False
  168.       Height          =   290
  169.       Left            =   60
  170.       TabIndex        =   2
  171.       Text            =   "txtLastName"
  172.       Top             =   1080
  173.       Width           =   2402
  174.    End
  175.    Begin TextBox txtFirstName 
  176.       DataField       =   "Firstname"
  177.       DataSource      =   "datEmployeeDatabase"
  178.       FontBold        =   0   'False
  179.       FontItalic      =   0   'False
  180.       FontName        =   "MS Sans Serif"
  181.       FontSize        =   8.25
  182.       FontStrikethru  =   0   'False
  183.       FontUnderline   =   0   'False
  184.       Height          =   290
  185.       Left            =   60
  186.       TabIndex        =   1
  187.       Text            =   "txtFirstName"
  188.       Top             =   540
  189.       Width           =   2402
  190.    End
  191.    Begin Label lblBiography 
  192.       BackColor       =   &H00C0C0C0&
  193.       Caption         =   "Biography"
  194.       FontBold        =   0   'False
  195.       FontItalic      =   0   'False
  196.       FontName        =   "MS Sans Serif"
  197.       FontSize        =   9.75
  198.       FontStrikethru  =   0   'False
  199.       FontUnderline   =   0   'False
  200.       Height          =   285
  201.       Left            =   1440
  202.       TabIndex        =   0
  203.       Top             =   1995
  204.       Width           =   1095
  205.    End
  206.    Begin Label lblStartDate 
  207.       BackColor       =   &H00C0C0C0&
  208.       Caption         =   "Start Date"
  209.       FontBold        =   0   'False
  210.       FontItalic      =   0   'False
  211.       FontName        =   "MS Sans Serif"
  212.       FontSize        =   9.75
  213.       FontStrikethru  =   0   'False
  214.       FontUnderline   =   0   'False
  215.       Height          =   255
  216.       Left            =   60
  217.       TabIndex        =   7
  218.       Top             =   1350
  219.       Width           =   1020
  220.    End
  221.    Begin Label lblLastName 
  222.       BackColor       =   &H00C0C0C0&
  223.       Caption         =   "Last Name"
  224.       FontBold        =   0   'False
  225.       FontItalic      =   0   'False
  226.       FontName        =   "MS Sans Serif"
  227.       FontSize        =   9.75
  228.       FontStrikethru  =   0   'False
  229.       FontUnderline   =   0   'False
  230.       Height          =   330
  231.       Left            =   60
  232.       TabIndex        =   6
  233.       Top             =   825
  234.       Width           =   1020
  235.    End
  236.    Begin Label lblFirstName 
  237.       BackColor       =   &H00C0C0C0&
  238.       Caption         =   "First Name"
  239.       FontBold        =   0   'False
  240.       FontItalic      =   0   'False
  241.       FontName        =   "MS Sans Serif"
  242.       FontSize        =   9.75
  243.       FontStrikethru  =   0   'False
  244.       FontUnderline   =   0   'False
  245.       Height          =   300
  246.       Left            =   60
  247.       TabIndex        =   5
  248.       Top             =   270
  249.       Width           =   1035
  250.    End
  251. End
  252. Option Explicit
  253. '-----------------------------------------
  254. Dim strDirectoryName As String  'Holds the name of the directory from which VisiBase was launched. Used to create a full path for accessing the database records and the photographs.
  255.  
  256. 'The "intEntry" variable is set or reset throughout the project to prevent multiple triggering of Text Box updates.
  257. '   without "intEntry" the program would not know whether or not the user were changing (editing) the database,
  258. '   or simply moving through it, viewing records. See the AddRecord Event for more.
  259. Dim intEntry As Integer
  260.  
  261. Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFileName$)
  262. Dim strWordDir$ ' Used to get the results from the GetWordDir function
  263.  
  264. 'UpdateOptions
  265. Const OLE_AUTOMATIC = 0
  266. Const OLE_MANUAL = 2
  267.  
  268. 'OLE Control Actions
  269. Const OLE_UPDATE = 6
  270.  
  271. Sub AddRecord_Click ()
  272.     Dim n As String
  273.     
  274.     Static toggle As Integer
  275.     toggle = Not toggle
  276.     If toggle = True Then
  277.     addrecord.Caption = "Confir&m"
  278.     intEntry = True
  279.     Else
  280.     addrecord.Caption = "&Add"
  281.     intEntry = False
  282.     End If
  283.     
  284.     On Error Resume Next
  285.     
  286.     If intEntry = True Then 'just starting an intEntry
  287.     datEmployeeDatabase.Recordset.AddNew
  288.     txtFirstName.SetFocus
  289.     Else                    'confirming an intEntry
  290.     datEmployeeDatabase.Recordset.Update
  291.     If Err Then
  292.         addrecord.Caption = "Confir&m"
  293.         toggle = Not toggle
  294.     End If
  295.     
  296.     datEmployeeDatabase.Recordset.MoveLast
  297.     txtFirstName.SetFocus
  298.     End If
  299. End Sub
  300.  
  301. Sub AddRecord_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  302.     helpbar.Caption = " Click here to add a new employee record."
  303. End Sub
  304.  
  305. Sub Change_Click ()
  306.     On Error Resume Next
  307.     Dim n As String, a As String
  308.     Dim fh As Integer
  309.     Dim bmpdat As String
  310.  
  311.     helpbar.Caption = " UPDATING WINWORD DOCUMENT." 'Explain the pause to the user
  312.     
  313.     Dim WordObj As object, years As Variant, le As Single
  314.     
  315.     Set WordObj = CreateObject("Word.Basic")
  316.     
  317.     'WordObj.FileOpen strWordDir$ & "\TEMPLATE\EMPLOYEE.DOT"
  318.     WordObj.FileOpen app.Path + "\EMPLOYEE.DOT"
  319.     WordObj.StartOfDocument
  320.     
  321.     WordObj.EditGoTo "d'DATE'"  ' Locate Date Field
  322.     WordObj.UpdateFields        ' Update date
  323.     
  324.     WordObj.EditGoTo "headname" ' Find headline bookmark
  325.     WordObj.EndOfLine 1         ' Select entire line
  326.     
  327.     ' Calculate length of Employee Name
  328.     n$ = txtFirstName.Text & " " & txtLastName.Text
  329.     le = Len(n$)
  330.     Select Case le ' Change headline fontsize to avoid line breaks
  331.     Case 0 To 17
  332.         WordObj.FontSize 36
  333.     Case 18 To 25
  334.         WordObj.FontSize 24
  335.     Case 25 To 200
  336.         WordObj.FontSize 18
  337.     End Select
  338.     
  339.     WordObj.Insert UCase$(n$)   ' Insert Employee name
  340.     WordObj.EditGoTo "photo"    ' Locate "photo" bookmark
  341.     WordObj.CharRight 1, 1      ' Select photo
  342.     WordObj.EditClear           ' Delete old photo
  343.     ' Insert photo
  344.     fh = FreeFile
  345.     Open strDirectoryName$ & "photo.bmp" For Binary As fh
  346.     bmpdat = datEmployeeDatabase.Recordset!Photo
  347.     Put fh, , bmpdat
  348.     Close fh
  349.     If Len(bmpdat) = 0 Or Err Then   'picture is too big or blank
  350.       WordObj.InsertPicture strDirectoryName$ & "nopic.bmp"
  351.       If Err Then Err = 0    'reset
  352.     Else
  353.       WordObj.InsertPicture strDirectoryName$ & "photo.bmp"
  354.     End If
  355.  
  356.     Kill strDirectoryName$ & "photo.bmp"
  357.  
  358.     WordObj.EditGoTo "caption"  ' Locate "caption" bookmark
  359.     ' Figure out how many years the employee has worked for BeBe
  360.     If txtStartDate.Text = "" Then ' If no start date is in the record
  361.     a$ = txtStartDate.Text     ' Simply use employee name as caption.
  362.     GoTo nodate
  363.     End If
  364.     
  365.     ' Calculate how many years employed
  366.     years = Year(Now) - Year(txtStartDate.Text)
  367.     a$ = n$ & " has worked at BeBe for "
  368.     Select Case years
  369.     Case Is < 1
  370.         a$ = a$ & "less than one year."
  371.     Case 1 To 2
  372.         a$ = a$ & "about a year."
  373.     Case Else
  374.         a$ = a$ & years & " years."
  375.     End Select
  376.     
  377. nodate:
  378.     WordObj.Insert a$           ' Insert caption
  379.     WordObj.EndOfDocument 1     ' Select all text to end of document
  380.     WordObj.EditClear           ' Delete it
  381.     WordObj.InsertPara          ' Move down two lines
  382.     WordObj.InsertPara
  383.     WordObj.Insert txtBiography.Text   ' Insert biographical narrative
  384.     WordObj.FileSave            ' Save the file to disk
  385.     Set WordObj = Nothing       ' Release memory/resources
  386.     
  387.     helpbar.Caption = ""
  388.     
  389.     ' Change update options to MANUAL before manually
  390.     ' updating the OLE control. After the manual update,
  391.     ' reset update options to AUTOMATIC so that the user
  392.     ' can double-click to open the document.
  393.     OLEWordDocument.UpdateOptions = OLE_MANUAL
  394.     OLEWordDocument.Action = OLE_UPDATE
  395.     OLEWordDocument.UpdateOptions = OLE_AUTOMATIC
  396.  
  397.     If Err Then MsgBox "Error:" & Err & Chr(13) & Chr(10) & (Error$(Err))
  398. End Sub
  399.  
  400. Sub Change_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  401.     helpbar.Caption = " Automatically brings up Word, inserts the current record's data, then saves EMPLOYEE.DOT to disk."
  402. End Sub
  403.  
  404. Sub cmdExit_Click ()
  405.     On Error Resume Next
  406.     Unload Me
  407. End Sub
  408.  
  409. Sub cmdExit_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  410.     helpbar.Caption = " Saves any editing or other changes to disk, then closes this program."
  411. End Sub
  412.  
  413. Sub datEmployeeDatabase_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  414.     helpbar.Caption = " The inner arrows move you one record in either direction.  The outer move to the first or last."
  415. End Sub
  416.  
  417. Sub DeleteRecord_Click ()
  418.     Dim x As Long
  419.  
  420.     On Error Resume Next
  421.  
  422.     'check for adding record state
  423.     If addrecord.Caption = "Confir&m" Then Exit Sub
  424.  
  425.     'check recordcount to disallow removing the last record
  426.     Dim ds As dynaset
  427.     Set ds = datEmployeeDatabase.Recordset.Clone()
  428.     ds.MoveLast
  429.     x = ds.RecordCount
  430.     ds.Close
  431.  
  432.     If x = 1 Then
  433.       Beep
  434.       MsgBox "You cannot delete the last record!", 16
  435.       Exit Sub
  436.     End If
  437.  
  438.     If MsgBox("Are you sure you want to delete '" & datEmployeeDatabase.Recordset!Lastname & "'?", 292) <> 6 Then
  439.       Exit Sub
  440.     End If
  441.     
  442.     ' Delete the record
  443.     datEmployeeDatabase.Recordset.Delete
  444.     
  445.     ' move to the next record to get off of the deleted one
  446.     datEmployeeDatabase.Recordset.MoveNext
  447.  
  448. End Sub
  449.  
  450. Sub DeleteRecord_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  451.     helpbar.Caption = " Click here to delete the currently visible employee record."
  452. End Sub
  453.  
  454. Sub Form_Load ()
  455.     Dim strProb As String       ' Used to display message if link fails.
  456.     Dim strOledir As String     ' Used to create OLE link
  457.     On Error Resume Next
  458.     Dim intPos As Integer, strSelected As String
  459.     
  460.     ' Set mouse pointer to hourglass
  461.     Screen.MousePointer = 11
  462.     
  463.     ' Center the form
  464.     left = (Screen.Width / 2) - (Width / 2)
  465.     top = (Screen.Height / 2) - (Height / 2)
  466.     
  467.     ' Find out the directory where Winword lives
  468.     strWordDir$ = getworddir()
  469.     ' Remove extra zeros at end of meaningful info.
  470.     intPos = InStr(strWordDir$, Chr$(0))'
  471.     strWordDir$ = Left$(strWordDir$, intPos - 1)
  472.     
  473.     ' Find out the directory where VISIBASE lives
  474.     strDirectoryName$ = app.Path
  475.     ' Strip out the backslash
  476.     If Right$(strDirectoryName$, 1) <> "\" Then strDirectoryName$ = strDirectoryName$ + "\"
  477.     
  478.     ' Set the data control's DatabaseName and RecordSource properties
  479.     datEmployeeDatabase.DatabaseName = strDirectoryName$ & "VisiBase.MDB"
  480.     datEmployeeDatabase.RecordSource = "personnel"
  481.     
  482.     ' Prevent multiple triggering of Text Box updates
  483.     intEntry = True
  484.     
  485.     ' Set bound controls DataField property
  486.     txtFirstName.DataField = "Firstname"
  487.     txtLastName.DataField = "Lastname"
  488.     txtStartDate.DataField = "Startdate"
  489.     txtBiography.DataField = "bio"
  490.           
  491.     ' Fill OLE Control
  492.     OLEWordDocument.Class = "WordDocument.6"
  493.     OLEWordDocument.SourceDoc = app.Path + "\EMPLOYEE.DOT"
  494.     OLEWordDocument.Action = 1
  495.     ' Handle any OLE errors
  496.     If Err Then
  497.     strProb$ = "We cannot create a link to "
  498.     strProb$ = strProb$ & OLEWordDocument.SourceDoc
  499.     strProb$ = strProb$ & ". Please be sure that this file "
  500.     strProb$ = strProb$ & "is in the proper directory."
  501.     MsgBox strProb$
  502.     End If
  503.     
  504.     ' Show the form
  505.     Show
  506.     
  507.     ' Reset mouse pointer
  508.     Screen.MousePointer = 0
  509. End Sub
  510.  
  511. Sub Form_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  512.     helpbar.Caption = ""
  513. End Sub
  514.  
  515. Sub Form_Unload (Cancel As Integer)
  516.     On Error Resume Next
  517.  
  518.     ' On exit, save any changes into the database
  519.     datEmployeeDatabase.Recordset.Update
  520. End Sub
  521.  
  522. Function getworddir () As String
  523.     '******************************************************
  524.     'Purpose:   This procedure utilizes the API routine called
  525.     '           GetPrivateProfileString to find out the location of
  526.     '           Word for Windows on the user's disk drive.
  527.     '           WinWord 6.0 does not provide information about
  528.     '           itself in WIN.INI (unlike Word 2.0). Rather, it uses
  529.     '           its own .INI file called WINWORD6.INI.
  530.     '
  531.     'Returns:   A string containing the directory name where
  532.     '           Word for Windows is located
  533.     '*******************************************************
  534.     Dim StrAnswerString As String * 50 ' Create a fixed-length string to hold the answer.
  535.     Dim d As Integer ' A necessary, though ignored by us, return variable for use with the API function.
  536.     
  537.     d = GetPrivateProfileString("Microsoft Word", "programdir", "not", StrAnswerString, 49, "Winword6.ini")
  538.     getworddir = StrAnswerString
  539. End Function
  540.  
  541. Sub imgPhoto_DblClick ()
  542.   On Error Resume Next
  543.  
  544.   Dim picfn As String
  545.  
  546.   picfn = InputBox("Enter file name to load for Photo")
  547.  
  548.   If picfn = "" Then Exit Sub
  549.   If Len(Dir(picfn)) = 0 Then
  550.     MsgBox picfn & " not found!"
  551.     Exit Sub
  552.   End If
  553.   imgPhoto.Picture = LoadPicture(picfn)
  554.  
  555. End Sub
  556.  
  557. Sub imgPhoto_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  558.     helpbar.Caption = " This is the photo for the current record. (DblClick to Load Picture)"
  559. End Sub
  560.  
  561. Sub lblFirstName_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  562.     helpbar.Caption = " Type in or modify the employee's first name for the current record."
  563. End Sub
  564.  
  565. Sub lblLastName_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  566.     helpbar.Caption = " Type in or modify the employee's last name for the current record."
  567. End Sub
  568.  
  569. Sub lblStartDate_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  570.     helpbar.Caption = " Type in or modify the date that the employee's started working here."
  571. End Sub
  572.  
  573. Sub oleWordDocument_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  574.     helpbar.Caption = " Double-click here to bring up Word for fine-tuning the Newsletter."
  575. End Sub
  576.  
  577. Sub txtBiography_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  578.     helpbar.Caption = " Type in or modify information about the employee that you want in the Newsletter article."
  579. End Sub
  580.  
  581. Sub txtFirstName_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  582.     helpbar.Caption = " Type in or modify the employee's first name for the current record."
  583. End Sub
  584.  
  585. Sub txtLastName_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  586.     helpbar.Caption = " Type in or modify the employee's last name for the current record."
  587. End Sub
  588.  
  589. Sub txtStartDate_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)
  590.     helpbar.Caption = " Type in or modify the date that the employee's started working here."
  591. End Sub
  592.  
  593.